home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / num_comp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  6.4 KB  |  318 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     Comparisons on numbers
  24. */
  25. #include "include.h"
  26. #include "num_include.h"
  27. #include "mp.h"
  28. /*
  29.     The value of number_compare(x, y) is
  30.  
  31.         -1    if    x < y
  32.         0    if    x = y
  33.         1    if    x > y.
  34.  
  35.     If x or y is complex, 0 or 1 is returned.
  36. */
  37. int
  38. number_compare(x, y)
  39. object x, y;
  40. {
  41.     int i;
  42.     double dx, dy;
  43.     vs_mark;
  44.  
  45.     switch (type_of(x)) {
  46.  
  47.     case t_fixnum:
  48.         switch (type_of(y)) {
  49.         case t_fixnum:
  50.             if (fix(x) < fix(y))
  51.                 return(-1);
  52.             else if (fix(x) == fix(y))
  53.                 return(0);
  54.             else
  55.                 return(1);
  56.         case t_bignum:
  57.             i = big_sign(y);
  58.             if (i < 0)
  59.                 return(1);
  60.             else
  61.                 return(-1);
  62.         case t_ratio:
  63.             x = number_times(x, y->rat.rat_den);
  64.             y = y->rat.rat_num;
  65.             vs_push(x);
  66.             i = number_compare(x, y);
  67.             vs_reset;
  68.             return(i);
  69.         case t_shortfloat:
  70.             dx = (double)(fix(x));
  71.             dy = (double)(sf(y));
  72.             goto LONGFLOAT;
  73.         case t_longfloat:
  74.             dx = (double)(fix(x));
  75.             dy = lf(y);
  76.             goto LONGFLOAT;
  77.         case t_complex:
  78.             goto Y_COMPLEX;
  79.         default:
  80.             wrong_type_argument(Snumber, y);
  81.         }
  82.  
  83.     case t_bignum:
  84.         switch (type_of(y)) {
  85.         case t_fixnum:
  86.             i = big_sign(x);
  87.             if (i < 0)
  88.                 return(-1);
  89.             else
  90.                 return(1);
  91.         case t_bignum:
  92.              return cmpii(MP(x),MP(y));
  93.         case t_ratio:
  94.             x = number_times(x, y->rat.rat_den);
  95.             y = y->rat.rat_num;
  96.             vs_push(x);
  97.             i = number_compare(x, y);
  98.             vs_reset;
  99.             return(i);
  100.         case t_shortfloat:
  101.             dx = number_to_double(x);
  102.             dy = (double)(sf(y));
  103.             goto LONGFLOAT;
  104.         case t_longfloat:
  105.             dx = number_to_double(x);
  106.             dy = lf(y);
  107.             goto LONGFLOAT;
  108.         case t_complex:
  109.             goto Y_COMPLEX;
  110.         default:
  111.             wrong_type_argument(Snumber, y);
  112.         }
  113.  
  114.     case t_ratio:
  115.         switch (type_of(y)) {
  116.         case t_fixnum:
  117.         case t_bignum:
  118.             y = number_times(y, x->rat.rat_den);
  119.             x = x->rat.rat_num;
  120.             vs_push(y);
  121.             i = number_compare(x, y);
  122.             vs_reset;
  123.             return(i);
  124.         case t_ratio:
  125.             vs_push(number_times(x->rat.rat_num,y->rat.rat_den));
  126.             vs_push(number_times(y->rat.rat_num,x->rat.rat_den));
  127.             i = number_compare(vs_top[-2], vs_top[-1]);
  128.             vs_reset;
  129.             return(i);
  130.         case t_shortfloat:
  131.             dx = number_to_double(x);
  132.             dy = (double)(sf(y));
  133.             goto LONGFLOAT;
  134.         case t_longfloat:
  135.             dx = number_to_double(x);
  136.             dy = lf(y);
  137.             goto LONGFLOAT;
  138.         case t_complex:
  139.             goto Y_COMPLEX;
  140.         default:
  141.             wrong_type_argument(Snumber, y);
  142.         }
  143.  
  144.     case t_shortfloat:
  145.         dx = (double)(sf(x));
  146.         goto LONGFLOAT0;
  147.  
  148.     case t_longfloat:
  149.         dx = lf(x);
  150.     LONGFLOAT0:
  151.         switch (type_of(y)) {
  152.         case t_fixnum:
  153.             dy = (double)(fix(y));
  154.             goto LONGFLOAT;
  155.         case t_bignum:
  156.         case t_ratio:
  157.             dy = number_to_double(y);
  158.             goto LONGFLOAT;
  159.         case t_shortfloat:
  160.             dy = (double)(sf(y));
  161.             goto LONGFLOAT;
  162.         case t_longfloat:
  163.             dy = lf(y);
  164.             goto LONGFLOAT;
  165.         case t_complex:
  166.             goto Y_COMPLEX;
  167.         }
  168.     LONGFLOAT:
  169.         if (dx == dy)
  170.             return(0);
  171.         else if (dx < dy)
  172.             return(-1);
  173.         else
  174.             return(1);
  175.  
  176.     Y_COMPLEX:
  177.         if (number_zerop(y->cmp.cmp_imag))
  178.             if (number_compare(x, y->cmp.cmp_real) == 0)
  179.                 return(0);
  180.             else
  181.                 return(1);
  182.         else
  183.             return(1);
  184.  
  185.     case t_complex:
  186.         if (type_of(y) != t_complex)
  187.             if (number_zerop(x->cmp.cmp_imag))
  188.                 if (number_compare(x->cmp.cmp_real, y) == 0)
  189.                     return(0);
  190.                 else
  191.                     return(1);
  192.             else
  193.                 return(1);
  194.         if (number_compare(x->cmp.cmp_real, y->cmp.cmp_real) == 0 &&
  195.             number_compare(x->cmp.cmp_imag, y->cmp.cmp_imag) == 0 )
  196.             return(0);
  197.         else
  198.             return(1);
  199.  
  200.     default:
  201.         FEwrong_type_argument(Snumber, x);
  202.     }
  203. }
  204.  
  205. Lall_the_same()
  206. {
  207.     int narg, i;
  208.  
  209.     narg = vs_top - vs_base;
  210.     if (narg == 0)
  211.         too_few_arguments();
  212.     for (i = 0; i < narg; i++)
  213.         check_type_number(&vs_base[i]);
  214.     for (i = 1; i < narg; i++)
  215.         if (number_compare(vs_base[i-1], vs_base[i]) != 0) {
  216.             vs_top = vs_base+1;
  217.             vs_base[0] = Cnil;
  218.             return;
  219.         }
  220.     vs_top = vs_base+1;
  221.     vs_base[0] = Ct;
  222. }
  223.  
  224. Lall_different()
  225. {
  226.     int narg, i, j;
  227.  
  228.     narg = vs_top - vs_base;
  229.     if (narg == 0)
  230.         too_few_arguments();
  231.     else if (narg == 1) {
  232.         vs_base[0] = Ct;
  233.         return;
  234.     }
  235.     for (i = 0; i < narg; i++)
  236.         check_type_number(&vs_base[i]);
  237.     for(i = 1; i < narg; i++)
  238.         for(j = 0; j < i; j++)
  239.             if (number_compare(vs_base[j], vs_base[i]) == 0) {
  240.                 vs_top = vs_base+1;
  241.                 vs_base[0] = Cnil;
  242.                 return;
  243.             }
  244.     vs_top = vs_base+1;
  245.     vs_base[0] = Ct;
  246. }
  247.  
  248. Lnumber_compare(s, t)
  249. int s, t;
  250. {
  251.     int narg, i;
  252.  
  253.     narg = vs_top - vs_base;
  254.     if (narg == 0)
  255.         too_few_arguments();
  256.     for (i = 0; i < narg; i++)
  257.         check_type_or_rational_float(&vs_base[i]);
  258.     for (i = 1; i < narg; i++)
  259.         if (s*number_compare(vs_base[i], vs_base[i-1]) < t) {
  260.             vs_top = vs_base+1;
  261.             vs_base[0] = Cnil;
  262.             return;
  263.         }
  264.     vs_top = vs_base+1;
  265.     vs_base[0] = Ct;
  266. }
  267.  
  268. Lmonotonically_increasing()    { Lnumber_compare( 1, 1); }
  269. Lmonotonically_decreasing()    { Lnumber_compare(-1, 1); }
  270. Lmonotonically_nondecreasing() { Lnumber_compare( 1, 0); }
  271. Lmonotonically_nonincreasing() { Lnumber_compare(-1, 0); }
  272.  
  273. Lmax()
  274. {
  275.     object max;
  276.     int narg, i;
  277.     
  278.     narg = vs_top - vs_base;
  279.     if (narg == 0)
  280.         too_few_arguments();
  281.     for (i = 0;  i < narg;  i++)
  282.         check_type_or_rational_float(&vs_base[i]);
  283.     for (i = 1, max = vs_base[0];  i < narg;  i++)
  284.         if (number_compare(max, vs_base[i]) < 0)
  285.             max = vs_base[i];
  286.     vs_top = vs_base+1;
  287.     vs_base[0] = max;
  288. }
  289.  
  290. Lmin()
  291. {
  292.     object min;
  293.     int narg, i;
  294.     
  295.     narg = vs_top - vs_base;
  296.     if (narg == 0)
  297.         too_few_arguments();
  298.     for (i = 0;  i < narg;  i++)
  299.         check_type_or_rational_float(&vs_base[i]);
  300.     for (i = 1, min = vs_base[0];  i < narg;  i++)
  301.         if (number_compare(min, vs_base[i]) > 0)
  302.             min = vs_base[i];
  303.     vs_top = vs_base+1;
  304.     vs_base[0] = min;
  305. }
  306.  
  307. init_num_comp()
  308. {
  309.     make_function("=", Lall_the_same);
  310.     make_function("/=", Lall_different);
  311.     make_function("<", Lmonotonically_increasing);
  312.     make_function(">", Lmonotonically_decreasing);
  313.     make_function("<=", Lmonotonically_nondecreasing);
  314.     make_function(">=", Lmonotonically_nonincreasing);
  315.     make_function("MAX", Lmax);
  316.     make_function("MIN", Lmin);
  317. }
  318.